home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0139_Mandelbrot and Julia Maker.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  4KB  |  116 lines
  1. {
  2. For all of you who are interested on fractals, here is a little program,
  3. taken from a source code in Modula-2, that will draw a Mandelbrot fractal.
  4.  
  5. Just one problem: If your computer doesn't have a math coprocessor, the
  6. program will run "a bit" slow :).
  7.  
  8. Try modifying all the constants, you'll get strange results :).
  9. }
  10.  
  11. {$X+ Enable Extended Syntax                                       }
  12.  
  13. Program Mandelbrot;     {Using real numbers. For TP 6.0 and above }
  14.  
  15. Uses Crt;               {Only to use "ReadKey" Function.          }
  16.  
  17. Const Colours=32;       {Number of colors to be on the image.     }
  18.       Width=320;        {Width of the image.                      }
  19.       Height=200;       {Height of the image.                     }
  20.       Limit=8.0;        {Until when we calculate.                 }
  21.       XRMin=-2.0;       {Left limit of the fractal.               }
  22.       XRMax=1.0;        {Right limit of the fractal.              }
  23.       YRMin=-1.3;       {Lower limit of the fractal.              }
  24.       YRMax=1.3;        {Upper limit of the fractal.              }
  25.  
  26. Type Palette=Array[0..767] of Byte;  {MCGA/VGA palette type       }
  27.  
  28. Var XPos,YPos:Word;
  29.  
  30. {Sets the desired video mode (13h)                                }
  31. Procedure SetVideoMode(VideoMode:Byte); Assembler;
  32. Asm
  33.   xor ax,ax                 {BIOS Function 00h: Set Video Mode.   }
  34.   mov al,VideoMode          {Desired Video Mode.                  }
  35.   int 10h
  36. End;
  37.  
  38. {Creates a palette: Black --> red --> yellow                      }
  39. Procedure MakePalette;
  40. Var CPal:Palette;
  41.     i:Byte;
  42.  
  43.   {Sets the palette.                                              }
  44.   Procedure SetPalette(Pal:Palette); Assembler;
  45.   Asm
  46.     push es
  47.     mov ax,1012h            {BIOS function 10h, subfunction 12h.  }
  48.     xor bx,bx               {first color register.                }
  49.     mov cx,20h              {number of color registers.           }
  50.     les dx,Pal              {ES:DX Segment:Offset of color table. }
  51.     Int 10h
  52.     pop es
  53.   End;
  54.  
  55. Begin
  56.   For i:=0 to 15 do
  57.   Begin
  58.     CPal[3*i]:=4*i+3; CPal[3*i+1]:=0; CPal[3*i+2]:=0;
  59.     CPal[3*i+48]:=63; CPal[3*i+49]:=4*i+3; CPal[3*i+50]:=0;
  60.   End;
  61.   SetPalette(CPal);
  62. End;
  63.  
  64. {Draws a Plot of the desired color on screen.                     }
  65. Procedure DrawPixel(XPos,YPos:Word; PlotColour:Byte);
  66. Begin
  67.   Mem[$A000:YPos*320+XPos]:=PlotColour;
  68. End;
  69.  
  70. {Needs to be explained? ;-)                                       }
  71. Procedure Beep;
  72. Begin
  73.   Sound(3000); Delay(90); Sound(2500); Delay(90);
  74.   NoSound;
  75. End;
  76.  
  77. {Calculates the color for each point.                             }
  78. Function ComputeColour(XPos,YPos:Word):Byte;
  79. Var RealP,ImagP:Real;
  80.     CurrX,CurrY:Real;
  81.     a2,b2:Real;
  82.     Counter:Byte;
  83. Begin
  84.   CurrX:=XPos/Width*(XRMax-XRMin)+XRMin;
  85.   CurrY:=YPos/Height*(YRMax-YRMin)+YRMin;
  86.   RealP:=0;
  87.   ImagP:=0;
  88.   Counter:=0;
  89.   Repeat
  90.     a2:=Sqr(RealP);
  91.     b2:=Sqr(ImagP);
  92.     ImagP:=2*RealP*ImagP+CurrY;
  93.     RealP:=a2-b2+CurrX;
  94.     Inc(Counter);
  95.   Until (Counter>=Colours) or (a2+b2>=Limit);
  96.   ComputeColour:=Counter-1;
  97. End;
  98.  
  99. Begin
  100.   Writeln('Program to draw Fractals of Mandelbrot.');
  101.   Writeln('Written by Miguel Martínez. ');
  102.   Writeln('Press any key to continue...');
  103.   If ReadKey=#0 Then ReadKey;   {Skip double codes.               }
  104.  
  105.   SetVideoMode(19);             {Set 320x200x256 graphics mode.   }
  106.   MakePalette;
  107.   For YPos:=0 to (Height-1) do
  108.     For XPos:=0 to (Width-1) do
  109.       DrawPixel(XPos,YPos,ComputeColour(XPos,YPos));
  110.   Beep;                         {Beep when finished.              }
  111.   If ReadKey=#0 Then ReadKey;
  112.   ReadKey;
  113.   SetVideoMode(3);              {Restore text mode.               }
  114. End.
  115.  
  116.